home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / lib / mathlib / libblas / src_original / cgbmv.f < prev    next >
Encoding:
Text File  |  1994-08-02  |  12.1 KB  |  388 lines
  1. *
  2. ************************************************************************
  3. *
  4. *     File of the COMPLEX          Level-2 BLAS.
  5. *     ==========================================
  6. *
  7. *     SUBROUTINE CGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
  8. *    $                   BETA, Y, INCY )
  9. *
  10. *     SUBROUTINE CGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
  11. *    $                   BETA, Y, INCY )
  12. *
  13. *     SUBROUTINE CHEMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
  14. *    $                   BETA, Y, INCY )
  15. *
  16. *     SUBROUTINE CHBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX,
  17. *    $                   BETA, Y, INCY )
  18. *
  19. *     SUBROUTINE CHPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
  20. *
  21. *     SUBROUTINE CTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
  22. *
  23. *     SUBROUTINE CTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
  24. *
  25. *     SUBROUTINE CTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
  26. *
  27. *     SUBROUTINE CTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
  28. *
  29. *     SUBROUTINE CTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
  30. *
  31. *     SUBROUTINE CTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
  32. *
  33. *     SUBROUTINE CGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
  34. *
  35. *     SUBROUTINE CGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
  36. *
  37. *     SUBROUTINE CHER  ( UPLO, N, ALPHA, X, INCX, A, LDA )
  38. *
  39. *     SUBROUTINE CHPR  ( UPLO, N, ALPHA, X, INCX, AP )
  40. *
  41. *     SUBROUTINE CHER2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
  42. *
  43. *     SUBROUTINE CHPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
  44. *
  45. *     See:
  46. *
  47. *        Dongarra J. J., Du Croz J. J., Hammarling S.  and Hanson R. J..
  48. *        An  extended  set of Fortran  Basic Linear Algebra Subprograms.
  49. *
  50. *        Technical  Memoranda  Nos. 41 (revision 3) and 81,  Mathematics
  51. *        and  Computer Science  Division,  Argonne  National Laboratory,
  52. *        9700 South Cass Avenue, Argonne, Illinois 60439, US.
  53. *
  54. *        Or
  55. *
  56. *        NAG  Technical Reports TR3/87 and TR4/87,  Numerical Algorithms
  57. *        Group  Ltd.,  NAG  Central  Office,  256  Banbury  Road, Oxford
  58. *        OX2 7DE, UK,  and  Numerical Algorithms Group Inc.,  1101  31st
  59. *        Street,  Suite 100,  Downers Grove,  Illinois 60515-1263,  USA.
  60. *
  61. ************************************************************************
  62. *
  63. *
  64. ************************************************************************
  65. *
  66.       SUBROUTINE CGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX,
  67.      $                   BETA, Y, INCY )
  68. *     .. Scalar Arguments ..
  69.       COMPLEX            ALPHA, BETA
  70.       INTEGER            INCX, INCY, KL, KU, LDA, M, N
  71.       CHARACTER*1        TRANS
  72. *     .. Array Arguments ..
  73.       COMPLEX            A( LDA, * ), X( * ), Y( * )
  74. *     ..
  75. *
  76. *  Purpose
  77. *  =======
  78. *
  79. *  CGBMV  performs one of the matrix-vector operations
  80. *
  81. *     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   or
  82. *
  83. *     y := alpha*conjg( A' )*x + beta*y,
  84. *
  85. *  where alpha and beta are scalars, x and y are vectors and A is an
  86. *  m by n band matrix, with kl sub-diagonals and ku super-diagonals.
  87. *
  88. *  Parameters
  89. *  ==========
  90. *
  91. *  TRANS  - CHARACTER*1.
  92. *           On entry, TRANS specifies the operation to be performed as
  93. *           follows:
  94. *
  95. *              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
  96. *
  97. *              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
  98. *
  99. *              TRANS = 'C' or 'c'   y := alpha*conjg( A' )*x + beta*y.
  100. *
  101. *           Unchanged on exit.
  102. *
  103. *  M      - INTEGER.
  104. *           On entry, M specifies the number of rows of the matrix A.
  105. *           M must be at least zero.
  106. *           Unchanged on exit.
  107. *
  108. *  N      - INTEGER.
  109. *           On entry, N specifies the number of columns of the matrix A.
  110. *           N must be at least zero.
  111. *           Unchanged on exit.
  112. *
  113. *  KL     - INTEGER.
  114. *           On entry, KL specifies the number of sub-diagonals of the
  115. *           matrix A. KL must satisfy  0 .le. KL.
  116. *           Unchanged on exit.
  117. *
  118. *  KU     - INTEGER.
  119. *           On entry, KU specifies the number of super-diagonals of the
  120. *           matrix A. KU must satisfy  0 .le. KU.
  121. *           Unchanged on exit.
  122. *
  123. *  ALPHA  - COMPLEX         .
  124. *           On entry, ALPHA specifies the scalar alpha.
  125. *           Unchanged on exit.
  126. *
  127. *  A      - COMPLEX          array of DIMENSION ( LDA, n ).
  128. *           Before entry, the leading ( kl + ku + 1 ) by n part of the
  129. *           array A must contain the matrix of coefficients, supplied
  130. *           column by column, with the leading diagonal of the matrix in
  131. *           row ( ku + 1 ) of the array, the first super-diagonal
  132. *           starting at position 2 in row ku, the first sub-diagonal
  133. *           starting at position 1 in row ( ku + 2 ), and so on.
  134. *           Elements in the array A that do not correspond to elements
  135. *           in the band matrix (such as the top left ku by ku triangle)
  136. *           are not referenced.
  137. *           The following program segment will transfer a band matrix
  138. *           from conventional full matrix storage to band storage:
  139. *
  140. *                 DO 20, J = 1, N
  141. *                    K = KU + 1 - J
  142. *                    DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
  143. *                       A( K + I, J ) = matrix( I, J )
  144. *              10    CONTINUE
  145. *              20 CONTINUE
  146. *
  147. *           Unchanged on exit.
  148. *
  149. *  LDA    - INTEGER.
  150. *           On entry, LDA specifies the first dimension of A as declared
  151. *           in the calling (sub) program. LDA must be at least
  152. *           ( kl + ku + 1 ).
  153. *           Unchanged on exit.
  154. *
  155. *  X      - COMPLEX          array of DIMENSION at least
  156. *           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
  157. *           and at least
  158. *           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
  159. *           Before entry, the incremented array X must contain the
  160. *           vector x.
  161. *           Unchanged on exit.
  162. *
  163. *  INCX   - INTEGER.
  164. *           On entry, INCX specifies the increment for the elements of
  165. *           X. INCX must not be zero.
  166. *           Unchanged on exit.
  167. *
  168. *  BETA   - COMPLEX         .
  169. *           On entry, BETA specifies the scalar beta. When BETA is
  170. *           supplied as zero then Y need not be set on input.
  171. *           Unchanged on exit.
  172. *
  173. *  Y      - COMPLEX          array of DIMENSION at least
  174. *           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
  175. *           and at least
  176. *           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
  177. *           Before entry, the incremented array Y must contain the
  178. *           vector y. On exit, Y is overwritten by the updated vector y.
  179. *
  180. *
  181. *  INCY   - INTEGER.
  182. *           On entry, INCY specifies the increment for the elements of
  183. *           Y. INCY must not be zero.
  184. *           Unchanged on exit.
  185. *
  186. *
  187. *  Level 2 Blas routine.
  188. *
  189. *  -- Written on 22-October-1986.
  190. *     Jack Dongarra, Argonne National Lab.
  191. *     Jeremy Du Croz, Nag Central Office.
  192. *     Sven Hammarling, Nag Central Office.
  193. *     Richard Hanson, Sandia National Labs.
  194. *
  195. *
  196. *     .. Parameters ..
  197.       COMPLEX            ONE
  198.       PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
  199.       COMPLEX            ZERO
  200.       PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
  201. *     .. Local Scalars ..
  202.       COMPLEX            TEMP
  203.       INTEGER            I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY,
  204.      $                   LENX, LENY
  205.       LOGICAL            NOCONJ
  206. *     .. External Functions ..
  207.       LOGICAL            LSAME
  208.       EXTERNAL           LSAME
  209. *     .. External Subroutines ..
  210.       EXTERNAL           XERBLA
  211. *     .. Intrinsic Functions ..
  212.       INTRINSIC          CONJG, MAX, MIN
  213. *     ..
  214. *     .. Executable Statements ..
  215. *
  216. *     Test the input parameters.
  217. *
  218.       INFO = 0
  219.       IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
  220.      $         .NOT.LSAME( TRANS, 'T' ).AND.
  221.      $         .NOT.LSAME( TRANS, 'C' )      )THEN
  222.          INFO = 1
  223.       ELSE IF( M.LT.0 )THEN
  224.          INFO = 2
  225.       ELSE IF( N.LT.0 )THEN
  226.          INFO = 3
  227.       ELSE IF( KL.LT.0 )THEN
  228.          INFO = 4
  229.       ELSE IF( KU.LT.0 )THEN
  230.          INFO = 5
  231.       ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN
  232.          INFO = 8
  233.       ELSE IF( INCX.EQ.0 )THEN
  234.          INFO = 10
  235.       ELSE IF( INCY.EQ.0 )THEN
  236.          INFO = 13
  237.       END IF
  238.       IF( INFO.NE.0 )THEN
  239.          CALL XERBLA( 'CGBMV ', INFO )
  240.          RETURN
  241.       END IF
  242. *
  243. *     Quick return if possible.
  244. *
  245.       IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
  246.      $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
  247.      $   RETURN
  248. *
  249.       NOCONJ = LSAME( TRANS, 'T' )
  250. *
  251. *     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
  252. *     up the start points in  X  and  Y.
  253. *
  254.       IF( LSAME( TRANS, 'N' ) )THEN
  255.          LENX = N
  256.          LENY = M
  257.       ELSE
  258.          LENX = M
  259.          LENY = N
  260.       END IF
  261.       IF( INCX.GT.0 )THEN
  262.          KX = 1
  263.       ELSE
  264.          KX = 1 - ( LENX - 1 )*INCX
  265.       END IF
  266.       IF( INCY.GT.0 )THEN
  267.          KY = 1
  268.       ELSE
  269.          KY = 1 - ( LENY - 1 )*INCY
  270.       END IF
  271. *
  272. *     Start the operations. In this version the elements of A are
  273. *     accessed sequentially with one pass through the band part of A.
  274. *
  275. *     First form  y := beta*y.
  276. *
  277.       IF( BETA.NE.ONE )THEN
  278.          IF( INCY.EQ.1 )THEN
  279.             IF( BETA.EQ.ZERO )THEN
  280.                DO 10, I = 1, LENY
  281.                   Y( I ) = ZERO
  282.    10          CONTINUE
  283.             ELSE
  284.                DO 20, I = 1, LENY
  285.                   Y( I ) = BETA*Y( I )
  286.    20          CONTINUE
  287.             END IF
  288.          ELSE
  289.             IY = KY
  290.             IF( BETA.EQ.ZERO )THEN
  291.                DO 30, I = 1, LENY
  292.                   Y( IY ) = ZERO
  293.                   IY      = IY   + INCY
  294.    30          CONTINUE
  295.             ELSE
  296.                DO 40, I = 1, LENY
  297.                   Y( IY ) = BETA*Y( IY )
  298.                   IY      = IY           + INCY
  299.    40          CONTINUE
  300.             END IF
  301.          END IF
  302.       END IF
  303.       IF( ALPHA.EQ.ZERO )
  304.      $   RETURN
  305.       KUP1 = KU + 1
  306.       IF( LSAME( TRANS, 'N' ) )THEN
  307. *
  308. *        Form  y := alpha*A*x + y.
  309. *
  310.          JX = KX
  311.          IF( INCY.EQ.1 )THEN
  312.             DO 60, J = 1, N
  313.                IF( X( JX ).NE.ZERO )THEN
  314.                   TEMP = ALPHA*X( JX )
  315.                   K    = KUP1 - J
  316.                   DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL )
  317.                      Y( I ) = Y( I ) + TEMP*A( K + I, J )
  318.    50             CONTINUE
  319.                END IF
  320.                JX = JX + INCX
  321.    60       CONTINUE
  322.          ELSE
  323.             DO 80, J = 1, N
  324.                IF( X( JX ).NE.ZERO )THEN
  325.                   TEMP = ALPHA*X( JX )
  326.                   IY   = KY
  327.                   K    = KUP1 - J
  328.                   DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL )
  329.                      Y( IY ) = Y( IY ) + TEMP*A( K + I, J )
  330.                      IY      = IY      + INCY
  331.    70             CONTINUE
  332.                END IF
  333.                JX = JX + INCX
  334.                IF( J.GT.KU )
  335.      $            KY = KY + INCY
  336.    80       CONTINUE
  337.          END IF
  338.       ELSE
  339. *
  340. *        Form  y := alpha*A'*x + y  or  y := alpha*conjg( A' )*x + y.
  341. *
  342.          JY = KY
  343.          IF( INCX.EQ.1 )THEN
  344.             DO 110, J = 1, N
  345.                TEMP = ZERO
  346.                K    = KUP1 - J
  347.                IF( NOCONJ )THEN
  348.                   DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL )
  349.                      TEMP = TEMP + A( K + I, J )*X( I )
  350.    90             CONTINUE
  351.                ELSE
  352.                   DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL )
  353.                      TEMP = TEMP + CONJG( A( K + I, J ) )*X( I )
  354.   100             CONTINUE
  355.                END IF
  356.                Y( JY ) = Y( JY ) + ALPHA*TEMP
  357.                JY      = JY      + INCY
  358.   110       CONTINUE
  359.          ELSE
  360.             DO 140, J = 1, N
  361.                TEMP = ZERO
  362.                IX   = KX
  363.                K    = KUP1 - J
  364.                IF( NOCONJ )THEN
  365.                   DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL )
  366.                      TEMP = TEMP + A( K + I, J )*X( IX )
  367.                      IX   = IX   + INCX
  368.   120             CONTINUE
  369.                ELSE
  370.                   DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL )
  371.                      TEMP = TEMP + CONJG( A( K + I, J ) )*X( IX )
  372.                      IX   = IX   + INCX
  373.   130             CONTINUE
  374.                END IF
  375.                Y( JY ) = Y( JY ) + ALPHA*TEMP
  376.                JY      = JY      + INCY
  377.                IF( J.GT.KU )
  378.      $            KX = KX + INCX
  379.   140       CONTINUE
  380.          END IF
  381.       END IF
  382. *
  383.       RETURN
  384. *
  385. *     End of CGBMV .
  386. *
  387.       END
  388.